home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / PASWIZ14.ZIP / SOURCE.ZIP / STRINGS.PAS < prev   
Pascal/Delphi Source File  |  1993-02-28  |  10KB  |  406 lines
  1. {   +----------------------------------------------------------------------+
  2.     |                                                                      |
  3.     |        PasWiz  Copyright (c) 1990-1993  Thomas G. Hanlin III         |
  4.     |             3544 E. Southern Ave. #104,  Mesa, AZ 85204              |
  5.     |                                                                      |
  6.     |                     The Pascal Wizard's Library                      |
  7.     |                                                                      |
  8.     +----------------------------------------------------------------------+
  9.  
  10.  
  11.  
  12. Strings:
  13.  
  14.    This unit provides extensions to Pascal's rather minimal string support.
  15.    This includes string trimming, substring extraction, uppercase/lowercase
  16.    conversions (handles names, too), simple encryption and compression,
  17.    assorted searches, advanced comparisons, and other useful tools.
  18.  
  19. }
  20.  
  21.  
  22.  
  23. UNIT Strings;
  24.  
  25.  
  26.  
  27. INTERFACE
  28.  
  29.  
  30.  
  31. FUNCTION Bickel (St1, St2: String): Integer;
  32. FUNCTION BSq (St: String): String;
  33. FUNCTION BUsq (St: String): String;
  34. FUNCTION Cipher (St, Passwd: String): String;
  35. FUNCTION CipherP (St, Passwd: String): String;
  36. FUNCTION Crunch (SubSt, St: String): String;
  37. FUNCTION Dupe (Count: Integer; SubSt: String): String;
  38. FUNCTION Extract (St, Delimiter: String; Index: Integer): String;
  39. FUNCTION Instr (Start: Integer; SubSt, St: String): Integer;
  40. FUNCTION Left (St: String; Len: Integer): String;
  41. FUNCTION LowerCase (St: String): String;
  42. FUNCTION LTrim (St: String): String;
  43. FUNCTION NameCase (St: String): String;
  44. FUNCTION Replace (OldSubSt, NewSubSt, St: String): String;
  45. FUNCTION Reverse (St: String): String;
  46. FUNCTION Right (St: String; Len: Integer): String;
  47. FUNCTION RPos (SubSt, St: String): Integer;
  48. FUNCTION RTrim (St: String): String;
  49. FUNCTION Soundex (St: String): String;
  50. FUNCTION StripCh (ChList, St: String): String;
  51. FUNCTION StripSt (SubSt, St: String): String;
  52. FUNCTION StripType (ChType: Integer; St: String): String;
  53. FUNCTION TypePos (ChType: Integer; St: String): Integer;
  54. FUNCTION UpperCase (St: String): String;
  55.  
  56.  
  57.  
  58. { --------------------------------------------------------------------------- }
  59.  
  60.  
  61.  
  62. IMPLEMENTATION
  63.  
  64.  
  65.  
  66. {$F+}
  67.  
  68. { routines in assembly language }
  69.  
  70. FUNCTION Bickel; external;           { string comparison by Bickel method }
  71. {$L BICKEL}
  72.  
  73. FUNCTION LowerCase; external;        { convert to lowercase }
  74. {$L LOCASE}
  75.  
  76. FUNCTION NameCase; external;         { capitalize a name appropriately }
  77. {$L NAMECASE}
  78.  
  79. FUNCTION UpperCase; external;        { convert to uppercase }
  80. {$L UPCASE}
  81.  
  82. FUNCTION Reverse; external;          { reverse a string }
  83. {$L REVERSE}
  84.  
  85. FUNCTION Soundex; external;          { string comparison by Soundex method }
  86. {$L SOUNDEX}
  87.  
  88. FUNCTION TypePos; external;          { seek a given type of character }
  89. {$L TYPEPOS}
  90.  
  91.  
  92.  
  93. { compress spaces in a string }
  94. FUNCTION BSq (St: String): String;
  95. VAR
  96.    SqSt: String;
  97.    Ptr, RepCount: Integer;
  98. BEGIN
  99.    SqSt := '';
  100.    RepCount := 0;
  101.    FOR Ptr := 1 TO Length(St) DO
  102.       IF St[Ptr] = ' ' THEN
  103.          INC(RepCount)
  104.       ELSE BEGIN
  105.          CASE RepCount OF
  106.             0: ;
  107.             1: IF Ptr = 2 THEN
  108.                   SqSt := ' '
  109.                ELSE
  110.                   SqSt[Length(SqSt)] := CHR(ORD(SqSt[Length(SqSt)]) OR $80);
  111.             2: SqSt := SqSt + CHR(ORD(' ') OR $80);
  112.             ELSE SqSt := SqSt + CHR($80) + CHR((RepCount - 3) OR $80);
  113.          END;
  114.          SqSt := SqSt + St[Ptr];
  115.          RepCount := 0;
  116.       END;
  117.    { flush any remaining spaces }
  118.    CASE RepCount OF
  119.       0: ;
  120.       1: IF St = ' ' THEN
  121.             SqSt := ' '
  122.          ELSE
  123.             SqSt[Length(SqSt)] := CHR(ORD(SqSt[Length(SqSt)]) OR $80);
  124.       2: SqSt := SqSt + CHR(ORD(' ') OR $80)
  125.       ELSE SqSt := SqSt + CHR($80) + CHR((RepCount - 3) OR $80);
  126.    END;
  127.    BSq := SqSt;
  128. END;
  129.  
  130.  
  131.  
  132. { uncompress a string processed by BSq }
  133. FUNCTION BUsq (St: String): String;
  134. VAR
  135.    UnsqSt: String;
  136.    Ptr: Integer;
  137. BEGIN
  138.    UnsqSt := '';
  139.    Ptr := 1;
  140.    WHILE Ptr <= Length(St) DO
  141.       CASE ORD(St[Ptr]) OF
  142.          0..$7F:    { ordinary chars }
  143.             BEGIN
  144.                UnsqSt := UnsqSt + St[Ptr];
  145.                INC(Ptr);
  146.             END;
  147.          $80:       { RLE sequence }
  148.             BEGIN
  149.                UnsqSt := UnsqSt + Dupe((ORD(St[Ptr + 1]) AND $7F) + 3, ' ');
  150.                INC(Ptr, 2);
  151.             END;
  152.          $81..$FF:  { character followed by one space }
  153.             BEGIN
  154.                UnsqSt := UnsqSt + CHR(ORD(St[Ptr]) AND $7F) + ' ';
  155.                INC(Ptr);
  156.             END;
  157.       END;
  158.    BUsq := UnsqSt;
  159. END;
  160.  
  161.  
  162.  
  163. { encipher or decipher a string }
  164. FUNCTION Cipher (St, Passwd: String): String;
  165. VAR
  166.    SPtr, PPtr: Integer;
  167. BEGIN
  168.    IF Length(Passwd) > 0 THEN BEGIN
  169.       PPtr := 1;
  170.       FOR SPtr := 1 TO Length(St) DO BEGIN
  171.          St[SPtr] := CHR(Ord(St[SPtr]) XOR Ord(Passwd[PPtr]));
  172.          INC(PPtr);
  173.          IF PPtr > Length(Passwd) THEN
  174.             PPtr := 1;
  175.       END;
  176.    END;
  177.    Cipher := St;
  178. END;
  179.  
  180.  
  181.  
  182. { encipher or decipher a string, with printable results }
  183. FUNCTION CipherP (St, Passwd: String): String;
  184. VAR
  185.    SPtr, PPtr: Integer;
  186. BEGIN
  187.    IF Length(Passwd) > 0 THEN BEGIN
  188.       PPtr := 1;
  189.       FOR SPtr := 1 TO Length(St) DO BEGIN
  190.          St[SPtr] := CHR(Ord(St[SPtr]) XOR Ord(Passwd[PPtr]) XOR $80);
  191.          INC(PPtr);
  192.          IF PPtr > Length(Passwd) THEN
  193.             PPtr := 1;
  194.       END;
  195.    END;
  196.    CipherP := St;
  197. END;
  198.  
  199.  
  200.  
  201. { remove adjacent occurrences of a given substring from a string }
  202. FUNCTION Crunch (SubSt, St: String): String;
  203. VAR
  204.    Two: String;
  205.    Posn: Integer;
  206. BEGIN
  207.    IF Length(SubSt) > 0 THEN BEGIN
  208.       Two := SubSt + SubSt;
  209.       REPEAT
  210.          Posn := Pos(Two, St);
  211.          IF Posn > 0 THEN
  212.             Delete(St, Posn, Length(SubSt));
  213.       UNTIL Posn = 0;
  214.    END;
  215.    Crunch := St;
  216. END;
  217.  
  218.  
  219.  
  220. { form a string of repeated substrings }
  221. FUNCTION Dupe (Count: Integer; SubSt: String): String;
  222. VAR
  223.    St: String;
  224. BEGIN
  225.    St := '';
  226.    WHILE Count > 0 DO BEGIN
  227.       St := St + SubSt;
  228.       DEC(Count);
  229.    END;
  230.    Dupe := St;
  231. END;
  232.  
  233.  
  234.  
  235. { extract a substring from a string partitioned by delimiters }
  236. FUNCTION Extract (St, Delimiter: String; Index: Integer): String;
  237. VAR
  238.    Start, SLen, Posn: Integer;
  239. BEGIN
  240.    Start := 1;
  241.    IF (Index > 0) AND (Length(Delimiter) > 0) THEN BEGIN
  242.       REPEAT
  243.          Posn := Instr(Start, Delimiter, St);
  244.          DEC(Index);
  245.          IF Index = 0 THEN
  246.             IF Posn > 0 THEN
  247.                SLen := Posn - Start
  248.             ELSE
  249.                SLen := Length(St) - Start + 1
  250.          ELSE IF Posn = 0 THEN
  251.             SLen := 0
  252.          ELSE
  253.             Start := Posn + Length(Delimiter);
  254.       UNTIL (Posn = 0) OR (Index = 0);
  255.    END
  256.    ELSE
  257.       SLen := 0;
  258.    Extract := Copy(St, Start, SLen);
  259. END;
  260.  
  261.  
  262.  
  263. { search for a substring within a string (like Pos but with start position) }
  264. FUNCTION Instr (Start: Integer; SubSt, St: String): Integer;
  265. VAR
  266.    Posn: Integer;
  267. BEGIN
  268.    Posn := Pos(SubSt, Copy(St, Start, 255));
  269.    IF Posn > 0 THEN
  270.       Posn := Posn + Start - 1;
  271.    Instr := Posn;
  272. END;
  273.  
  274.  
  275.  
  276. { return part of a string starting from the left side }
  277. FUNCTION Left (St: String; Len: Integer): String;
  278. BEGIN
  279.    Left := Copy(St, 1, Len);
  280. END;
  281.  
  282.  
  283.  
  284. { trim blanks from the left side of a string }
  285. FUNCTION LTrim (St: String): String;
  286. BEGIN
  287.    WHILE Copy(St, 1, 1) = ' ' DO
  288.       Delete(St, 1, 1);
  289.    LTrim := St;
  290. END;
  291.  
  292.  
  293.  
  294. { replace a given substring with another }
  295. FUNCTION Replace (OldSubSt, NewSubSt, St: String): String;
  296. VAR
  297.    Tmp: String;
  298.    Posn: Integer;
  299. BEGIN
  300.    IF Length(OldSubSt) > 0 THEN BEGIN
  301.       Tmp := '';
  302.       REPEAT
  303.          Posn := Pos(OldSubSt, St);
  304.          IF Posn > 0 THEN BEGIN
  305.             Tmp := Tmp + Copy(St, 1, Posn - 1) + NewSubSt;
  306.             Delete(St, 1, Posn + Length(OldSubSt) - 1);
  307.          END
  308.          ELSE
  309.             Tmp := Tmp + St;
  310.       UNTIL Posn = 0;
  311.       Replace := Tmp;
  312.    END
  313.    ELSE
  314.       Replace := St;
  315. END;
  316.  
  317.  
  318.  
  319. { return part of a string starting from the right side }
  320. FUNCTION Right (St: String; Len: Integer): String;
  321. BEGIN
  322.    IF Len >= Length(St) THEN
  323.       Right := St
  324.    ELSE
  325.       Right := Copy(St, Length(St) - Len + 1, 255);
  326. END;
  327.  
  328.  
  329.  
  330. { search for a substring, starting from the right side of a string }
  331. FUNCTION RPos (SubSt, St: String): Integer;
  332. VAR
  333.    Posn: Integer;
  334. BEGIN
  335.    Posn := Pos(Reverse(SubSt), Reverse(St));
  336.    IF Posn > 0 THEN
  337.       Posn := Length(St) - Length(SubSt) - Posn + 2;
  338.    RPos := Posn;
  339. END;
  340.  
  341.  
  342.  
  343. { trim blanks from the right side of a string }
  344. FUNCTION RTrim (St: String): String;
  345. BEGIN
  346.    WHILE Copy(St, Length(St), 1) = ' ' DO
  347.       Delete(St, Length(St), 1);
  348.    RTrim := St;
  349. END;
  350.  
  351.  
  352.  
  353. { strip all occurrences of a list of characters from a string }
  354. FUNCTION StripCh (ChList, St: String): String;
  355. VAR
  356.    Ptr: Integer;
  357.    Tmp: String;
  358. BEGIN
  359.    Tmp := '';
  360.    IF Length(ChList) > 0 THEN
  361.       FOR Ptr := 1 TO Length(St) DO
  362.          IF Pos(St[Ptr], ChList) = 0 THEN
  363.             Tmp := Tmp + St[Ptr];
  364.    StripCh := Tmp;
  365. END;
  366.  
  367.  
  368.  
  369. { strip all occurrences of a substring from a string }
  370. FUNCTION StripSt (SubSt, St: String): String;
  371. VAR
  372.    Posn: Integer;
  373. BEGIN
  374.    IF (Length(St) = 0) OR (Length(SubSt) = 0) THEN
  375.       StripSt := ''
  376.    ELSE BEGIN
  377.       REPEAT
  378.          Posn := Pos(SubSt, St);
  379.          IF Posn > 0 THEN
  380.             Delete(St, Posn, Length(SubSt));
  381.       UNTIL Posn = 0;
  382.       StripSt := St;
  383.    END;
  384. END;
  385.  
  386.  
  387.  
  388. { strip all occurrences of given types of character from a string }
  389. FUNCTION StripType (ChType: Integer; St: String): String;
  390. VAR
  391.    Posn: Integer;
  392. BEGIN
  393.    REPEAT
  394.       Posn := TypePos(ChType, St);
  395.       IF Posn > 0 THEN
  396.          Delete(St, Posn, 1);
  397.    UNTIL Posn = 0;
  398.    StripType := St;
  399. END;
  400.  
  401.  
  402.  
  403. { ----------------------- initialization code --------------------------- }
  404. BEGIN
  405. END.
  406.